home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: delta / whiteline CD Series - delta.iso / progtool / modula2 / m2d2 / funny / funny.mod < prev    next >
Text File  |  1995-11-25  |  17KB  |  492 lines
  1. MODULE Funny;
  2.  
  3. (*
  4.  * In diesem Accessory wird einmal gezeigt, wie einfach saubere
  5.  * GEM-Programmierung sein kann. In diesem Beispiel geht es um die Verwendung
  6.  * der CopyRaster-Funktion des VDI.
  7.  *
  8.  * Außerdem ist das Accessory eine nette kleine Spielerei, mit der auf
  9.  * dem Monitor interessante und effektvolle Bilder erzeugt werden können.
  10.  *
  11.  * (Tip: man spiele einmal mit mehreren Fenstern und dem Funny-Window als
  12.  *       unterem aber sichtbarem Fenster)
  13.  *
  14.  * Die Idee ist übrigens nicht auf meinem Mist gewachsen, denn ich habe
  15.  * einmal ein ähnliches, aber lange nicht so schönes, Programm auf einem
  16.  * Rechner einer fast unbekannten Firma (die Gründer waren wohl einmal 
  17.  * Apfelpflücker), laufen sehen.
  18.  *
  19.  * Das Programm wurde mit dem TDI-Modula-2/ST Release 3.01a erstellt.
  20.  * Bibliotheken, die nicht zum Standardlieferumfang von TDI gehören,
  21.  * wurden von *PSB erstellt und werden nicht mitgeliefert.
  22.  * Die Funktion der entsprechenden Routinen wird an geeigneter Stelle im
  23.  * Quelltext beschrienen.
  24.  *
  25.  * Erstellt an einem verregneten Nachmittag im Herbst '91
  26.  *
  27.  *                                                 (c) '91 Thomas Birke, *PSB
  28.  *
  29.  * Dank an all die fleißigen Teepflücker in Ceylon, Indien und Ostfriesland.
  30.  *
  31.  * *Pentagramm Software Braunschweig                    Thomas Birke
  32.  *                                                      Billrothstr. 31
  33.  *                                                      3300 Braunschweig
  34.  *)
  35.  
  36. (*$S-,$T-,$A+*)
  37.  
  38. FROM SYSTEM     IMPORT  ADR,    NULL;
  39.  
  40.  
  41. FROM GEMAES     IMPORT  ApplInitialise, MenuRegister,   EventMultiple,
  42.                         WindowCalc,     WindowCreate,   WindowOpen,
  43.                         WindowClose,    WindowDelete,   WindowUpdate,
  44.                         WindowGet,      WindowSet,      GrafHandle,
  45.                         FormDo,         FormCenter,     FormDialogue,
  46.                         ObjectDraw,     ResourceGetAddr;
  47.                         (* man suche in den jeweiligen AES-Bibliotheken *)
  48.  
  49.  
  50. FROM GEMAESbase IMPORT  AESGlobal,      WindowRedraw,   WindowTopped,
  51.                         WindowClosed,   WindowFulled,   WindowArrowed,
  52.                         WindowHorizSlided,              WindowVertSlided,
  53.                         WindowSized,    WindowMoved,    WindowNewTop,
  54.                         AccessoryOpen,  AccessoryClose, WindowName,
  55.                         WindowInfo,     WorkXYWH,       CurrXYWH,
  56.                         PrevXYWH,       FullXYWH,       WindowHorizSlide,
  57.                         WindowVertSlide,                Top,
  58.                         FirstXYWH,      NextXYWH,       NewDesk,
  59.                         HorizSliderSize,                VertSliderSize,
  60.                         WindowScreen,   BeginUpdate,    EndUpdate,
  61.                         FormStart,      FormGrow,       FormShrink,
  62.                         FormFinish,     RTree,          Name,
  63.                         Closer,         Fuller,         Mover,
  64.                         Sizer,          UpArrow,        DownArrow,
  65.                         VertSlide,      LeftArrow,      RightArrow,
  66.                         HorizSlide,     MesageEvent,    TimerEvent,
  67.                         Object,         osSELECTED;
  68.  
  69.  
  70. FROM GEMVDI     IMPORT  MFDBType,       CopyRasterOpaque,
  71.                         OpenVirtualWorkstation,
  72.                         CloseVirtualWorkstation,
  73.                         ExtendedInquire,
  74.                         SetClipping,    SampleMouseButton,
  75.                         HideCursor,     ShowCursor;
  76.                         (* siehe GEMAES, hier allerdings VDI            *)
  77.  
  78.  
  79. FROM GEMVDIbase IMPORT  PxyArrayType,   BigPxyArrayType,
  80.                         VDIWorkInType,  VDIWorkOutType;
  81.  
  82.  
  83. FROM Arithmetic IMPORT  RCIntersect,    Imax,           Imin;
  84.                         (* Imax und Imin brauchen wohl kaum erklärt zu
  85.                          * werden, RCIntersect ist da schon interessanter
  86.                          * C-Programmierer werden diese Funktion kennen.
  87.                          * RCIntersect prüft, ob sich zwei Rechtecke
  88.                          * schneiden, und gibt den entsprechenden
  89.                          * Wahrheitswert zurück. Zusätzlich werden in den
  90.                          * Koordinaten des ersten Rechtecks (VAR-Parameter)
  91.                          * die Koordinaten des Schnittrechtecks geliefert.
  92.                          *)
  93.  
  94.  
  95. FROM XGEMDOS    IMPORT  Alloc,          Free;       (* oder auch GEMDOS *)
  96.  
  97.  
  98. FROM FunnyRSC   IMPORT  RelocateRSC,    Alert,          Function;
  99.                         (* Da die Resource bei Accessories nicht
  100.                          * nachgeladen werden sollte, wird sie in den
  101.                          * Programmcode eingebunden.
  102.                          *)
  103.  
  104.  
  105. CONST   NoWindow        = -1;
  106.         Desktop         =  0;
  107.  
  108.         SourceToDest    =  3;
  109.  
  110.         Message         =  4;
  111.  
  112.  
  113.  
  114. TYPE    RectMFDB        = RECORD
  115.                              OffsetToWordBoundary,
  116.                              x, y,
  117.                              w, h                       : INTEGER;
  118.                              MFDB                       : MFDBType
  119.                           END;
  120.  
  121.  
  122.  
  123. VAR     ApplID,
  124.         MenuID,
  125.         VDIhandle,
  126.         WindowHandle,
  127.         occuredEvents           : INTEGER;
  128.  
  129.         MessageBuffer           : ARRAY [ 0..7 ] OF INTEGER;
  130.  
  131.         MouseX, MouseY,
  132.         MouseButtonState,
  133.         ShiftKeyState,
  134.         PressedKey, 
  135.         MouseClicks             : INTEGER;
  136.  
  137.         ScreenMFDB              : MFDBType;
  138.  
  139.         LastX, LastY,
  140.         DesktopX,
  141.         DesktopY,
  142.         DesktopWidth,
  143.         DesktopHeight,
  144.         DesktopXrechts,
  145.         DesktopYunten,
  146.         WindowX,
  147.         WindowY,
  148.         WindowWidth,
  149.         WindowHeight            : INTEGER;
  150.  
  151.         WindowTitle             : ARRAY [ 0..15 ] OF CHAR;
  152.  
  153.         Pxy                     : BigPxyArrayType;
  154.  
  155.         Rectangle               : RectMFDB;
  156.  
  157.         DialogBox               : POINTER TO ARRAY [ 0..Function ] OF Object;
  158.  
  159.         Planes                  : CARDINAL;
  160.  
  161.  
  162.  
  163. PROCEDURE Open;
  164.  
  165.    (* Der Eintrag des Accessories in der Menüzeile wurde gewählt        *)
  166.  
  167.    VAR  WorkIn  : VDIWorkInType;
  168.         WorkOut : VDIWorkOutType;
  169.         i       : INTEGER;
  170.         lc      : LONGCARD;
  171.  
  172.    BEGIN
  173.       IF WindowHandle = NoWindow  (* wenn noch kein Fenster offen ist : *)
  174.       THEN
  175.            FOR i := 0 TO 9 DO
  176.               WorkIn [ i ] := 1                    (* beim VDI anmelden *)
  177.            END;
  178.            WorkIn [ 10 ] := 2;
  179.            VDIhandle := GrafHandle ( i, i, i, i );
  180.            OpenVirtualWorkstation ( WorkIn, VDIhandle, WorkOut );
  181.  
  182.            Planes := AESGlobal.apNPlanes;
  183.  
  184.            WindowGet ( 0, WorkXYWH,
  185.                         DesktopX, DesktopY, DesktopWidth, DesktopHeight );
  186.  
  187.                            (* rechte untere Ecke des Desktops bestimmen *)
  188.            DesktopXrechts := DesktopX + DesktopWidth;
  189.            DesktopYunten := DesktopY + DesktopHeight;
  190.  
  191.            WindowHandle := WindowCreate ( HorizSlide + RightArrow + LeftArrow
  192.                                 + VertSlide + DownArrow + UpArrow
  193.                                 + Sizer + Mover + Fuller + Closer + Name,
  194.                                 DesktopX, DesktopY,
  195.                                 DesktopWidth, DesktopHeight );
  196.            IF WindowHandle = NoWindow
  197.            THEN CloseVirtualWorkstation ( VDIhandle );
  198.                 RETURN
  199.            END;
  200.  
  201.            lc := LONGCARD ( ADR ( WindowTitle ) );
  202.            WindowSet ( WindowHandle, WindowName,
  203.                        INTEGER ( lc DIV 65536 ), INTEGER ( lc MOD 65536 ),
  204.                        0, 0 );
  205.  
  206.            WindowSet ( WindowHandle, WindowHorizSlide, 500, 0, 0, 0 );
  207.            WindowSet ( WindowHandle, WindowVertSlide,  500, 0, 0, 0 );
  208.            WindowSet ( WindowHandle, HorizSliderSize,  333, 0, 0, 0 );
  209.            WindowSet ( WindowHandle, VertSliderSize,   333, 0, 0, 0 );
  210.  
  211.            WindowOpen ( WindowHandle,
  212.                         WindowX, WindowY, WindowWidth, WindowHeight )
  213.  
  214.       ELSE TopWindow           (* Falls schon ein Fenster geöffnet war, *)
  215.       END                         (* dieses zum obersten Fenster machen *)
  216.    END Open;
  217.  
  218.  
  219. PROCEDURE Close;
  220.  
  221.    (* Der Schließer des Fensters wurde vom Benutzer angeklickt *)
  222.  
  223.    BEGIN
  224.       WindowClose ( WindowHandle );
  225.       DeleteWindow
  226.    END Close;
  227.  
  228.  
  229. PROCEDURE DeleteWindow;
  230.  
  231.    (* Das Fenster ist bereits geschlossen, aber noch vorhanden. Es wird *)
  232.    (* gelöscht, und das VDI-Handle wird abgegeben.                      *)
  233.  
  234.    BEGIN
  235.       IF WindowHandle # NoWindow
  236.       THEN WindowDelete ( WindowHandle );
  237.            WindowHandle := NoWindow;
  238.            CloseVirtualWorkstation ( VDIhandle )
  239.       END
  240.    END DeleteWindow;
  241.  
  242.  
  243. PROCEDURE TopWindow;
  244.  
  245.    (* Das Fenster wird zum obersten Fenster auf dem Desktop             *)
  246.  
  247.    BEGIN
  248.       WindowSet ( WindowHandle, Top, 0, 0, 0, 0 )
  249.    END TopWindow;
  250.  
  251.  
  252. PROCEDURE Full;
  253.  
  254.    (* Der 'Fuller' des Fensters wurde angeklickt.                       *)
  255.  
  256.    VAR  X, Y, W, H,
  257.         x, y, w, h      : INTEGER;
  258.  
  259.    BEGIN
  260.       WindowGet ( WindowHandle, FullXYWH, X, Y, W, H );
  261.       WindowGet ( WindowHandle, CurrXYWH, x, y, w, h );
  262.       IF ( x = X ) AND ( y = Y ) AND ( w = W ) AND ( h = H )
  263.       THEN WindowGet ( WindowHandle, PrevXYWH, X, Y, W, H )
  264.       END;
  265.       WindowSet ( WindowHandle, CurrXYWH, X, Y, W, H )
  266.    END Full;
  267.  
  268.  
  269. PROCEDURE Size;
  270.  
  271.    (* Das Fenster wurde in seiner Größe geändert                        *)
  272.  
  273.    BEGIN
  274.       WindowX := MessageBuffer [ 4 ];
  275.       WindowY := MessageBuffer [ 5 ];
  276.       WindowWidth := MessageBuffer [ 6 ];
  277.       WindowHeight := MessageBuffer [ 7 ];
  278.       WindowSet ( WindowHandle, CurrXYWH,
  279.                   WindowX, WindowY, WindowWidth, WindowHeight )
  280.    END Size;
  281.  
  282.  
  283. PROCEDURE Arrow ( direction : INTEGER );
  284.  
  285.    (* Im Fenster wurde einer der Pfeile oder der grauen Balken betätigt *)
  286.  
  287.    BEGIN
  288.       CASE direction OF
  289.          0 : NotImplemented ( '"Seite aufwärts blättern"' )     |
  290.          1 : NotImplemented ( '"Seite abwärts blättern"' )      |
  291.          2 : NotImplemented ( '"Zeile aufwärts blättern"' )     |
  292.          3 : NotImplemented ( '"Zeile abwärts blättern"' )      |
  293.          4 : NotImplemented ( '"Seite nach links blättern"' )   |
  294.          5 : NotImplemented ( '"Seite nach rechts blättern"' )  |
  295.          6 : NotImplemented ( '"Spalte nach links blättern"' )  |
  296.          7 : NotImplemented ( '"Spalte nach rechts blättern"' ) |
  297.         ELSE
  298.       END
  299.    END Arrow;
  300.  
  301.  
  302. PROCEDURE Redraw;
  303.  
  304.    (* Ein Neuzeichnen des Fensterinhaltes ist erforderlich              *)
  305.  
  306.    VAR  X, Y, W, H,
  307.         WorkX,
  308.         WorkY,
  309.         WorkWidth,
  310.         WorkHeight      : INTEGER;
  311.         lc              : LONGCARD;
  312.  
  313.    BEGIN
  314.       WindowGet ( WindowHandle, WorkXYWH,
  315.                   WorkX, WorkY, WorkWidth, WorkHeight );
  316.  
  317.       MouseX := Imin ( MouseX, DesktopXrechts - WorkWidth );
  318.       MouseY := Imin ( MouseY, DesktopYunten - WorkHeight );
  319.       IF ( MouseX = LastX ) AND ( MouseY = LastY ) THEN RETURN END;
  320.  
  321.       LastX := MouseX;
  322.       LastY := MouseY;
  323.  
  324.       WindowUpdate ( BeginUpdate );
  325.       HideCursor ( VDIhandle );
  326.  
  327.       SaveRectangle ( MouseX, MouseY, WorkWidth, WorkHeight );
  328.  
  329.       IF Rectangle.MFDB.pointer # NULL
  330.       THEN
  331.            WindowGet ( WindowHandle, FirstXYWH, X, Y, W, H );
  332.  
  333.            WHILE ( W # 0 ) OR ( H # 0 ) DO
  334.  
  335.               IF RCIntersect ( X, Y, W, H,
  336.                         WorkX, WorkY, WorkWidth, WorkHeight ) AND
  337.                  RCIntersect ( X, Y, W, H,
  338.                         DesktopX, DesktopY, DesktopWidth, DesktopHeight )
  339.               THEN 
  340.                    WITH Rectangle DO
  341.                       Pxy [ 0 ] := OffsetToWordBoundary + X - WorkX;
  342.                       Pxy [ 1 ] := Y - WorkY;
  343.                       Pxy [ 2 ] := Pxy [ 0 ] + W - 1;
  344.                       Pxy [ 3 ] := Pxy [ 1 ] + H - 1;
  345.                       Pxy [ 4 ] := X;
  346.                       Pxy [ 5 ] := Y;
  347.                       Pxy [ 6 ] := X + W - 1;
  348.                       Pxy [ 7 ] := Y + H - 1;
  349.                       CopyRasterOpaque ( VDIhandle, SourceToDest, Pxy,
  350.                                          ADR ( MFDB ), ADR ( ScreenMFDB ) )
  351.                    END;
  352.               END;
  353.               WindowGet ( WindowHandle, NextXYWH, X, Y, W, H )
  354.            END;
  355.            WITH Rectangle.MFDB DO
  356.               IF Free ( pointer ) THEN END;
  357.               pointer := NULL
  358.            END;
  359.       END;
  360.  
  361.       ShowCursor ( VDIhandle, 0 );
  362.       WindowUpdate ( EndUpdate )
  363.    END Redraw;
  364.  
  365.  
  366. PROCEDURE SaveRectangle ( bx, by, bw, bh : INTEGER );
  367.  
  368.    (* Der Bildschirm-Ausschnitt mit den Koordinaten (bx,by,bw,bh) wird  *)
  369.    (* gesichert                                                         *)
  370.  
  371.    VAR  Pxy     : BigPxyArrayType;
  372.  
  373.    BEGIN
  374.  
  375.       WITH Rectangle DO
  376.          WITH MFDB DO
  377.             x := bx;
  378.             y := by;
  379.             w := bw;
  380.             h := bh;
  381.             OffsetToWordBoundary := x MOD 16;
  382.             width := bw;
  383.             height := bh;
  384.             widthW := ( bw DIV 16 ) + 2;
  385.             format := 0;
  386.             planes := Planes;
  387.             Alloc ( LONGCARD ( widthW ) * LONGCARD ( bh )
  388.                     * LONGCARD ( Planes ) * 2, pointer );
  389.             IF pointer = NULL THEN RETURN END
  390.          END;
  391.          Pxy [ 0 ] := bx;
  392.          Pxy [ 1 ] := by;
  393.          Pxy [ 2 ] := bx + bw - 1;
  394.          Pxy [ 3 ] := by + bh - 1;
  395.          Pxy [ 4 ] := OffsetToWordBoundary;
  396.          Pxy [ 5 ] := 0;
  397.          Pxy [ 6 ] := OffsetToWordBoundary + bw - 1;
  398.          Pxy [ 7 ] := bh - 1;
  399.          CopyRasterOpaque ( VDIhandle, SourceToDest, Pxy,
  400.                             ADR ( ScreenMFDB ), ADR ( MFDB ) )
  401.       END
  402.    END SaveRectangle;
  403.  
  404.  
  405. PROCEDURE Msg;
  406.  
  407.    (* Vom System kam eine Message, die nun bearbeitet werden muß        *)
  408.  
  409.    BEGIN
  410.       CASE MessageBuffer [ 0 ] OF
  411.          AccessoryOpen     : Open                                       |
  412.          AccessoryClose    : DeleteWindow                               |
  413.          WindowRedraw      : DEC ( LastX );
  414.                              Redraw                                     |
  415.          WindowTopped      : TopWindow                                  |
  416.          WindowClosed      : Close                                      |
  417.          WindowFulled      : Full                                       |
  418.          WindowSized,
  419.          WindowMoved       : Size                                       |
  420.          WindowArrowed     : Arrow ( MessageBuffer [ 4 ] )              |
  421.          WindowHorizSlided : NotImplemented ( '"horizontal scrollen"' ) |
  422.          WindowVertSlided  : NotImplemented ( '"vertikal scrollen"' )   |
  423.         ELSE
  424.       END
  425.    END Msg;
  426.  
  427.  
  428. PROCEDURE NotImplemented ( VAR s : ARRAY OF CHAR );
  429.  
  430.    (* bringt eine Dialogbox mit entsprechender Meldung auf den          *)
  431.    (* Bildschirm                                                        *)
  432.  
  433.    VAR  returnButton,
  434.         x, y, w, h      : INTEGER;
  435.  
  436.    BEGIN
  437.       IF MouseButtonState = 0  (* nur wenn keine Maustaste gedrückt ist *)
  438.       THEN
  439.            DialogBox^[ Function ].obSpec := ADR ( s );   (* Inh. setzen *)
  440.  
  441.            FormCenter ( DialogBox, x, y, w, h );
  442.            FormDialogue ( FormStart, 0, 0, 0, 0, x, y, w, h );
  443.            FormDialogue ( FormGrow, 0, 0, 0, 0, x, y, w, h );
  444.            ObjectDraw ( DialogBox, 0, 8, x, y, w, h );
  445.  
  446.            returnButton := FormDo ( DialogBox, 0 );
  447.            EXCL ( DialogBox^[ returnButton ].obState, osSELECTED );
  448.  
  449.            FormDialogue ( FormFinish, 0, 0, 0, 0, x, y, w, h );
  450.            FormDialogue ( FormShrink, 0, 0, 0, 0, x, y, w, h )
  451.       END
  452.    END NotImplemented;
  453.  
  454.  
  455.  
  456. BEGIN
  457.  
  458.    ApplID := ApplInitialise ();
  459.    MenuID := MenuRegister ( ApplID, '  Funny-Window' );
  460.  
  461.    RelocateRSC;
  462.    ResourceGetAddr ( RTree, Alert, DialogBox );
  463.  
  464.    ScreenMFDB.pointer := NULL;
  465.  
  466.    WindowHandle := NoWindow;
  467.    WindowTitle := ' Funny ';
  468.  
  469.    WindowX := 48;
  470.    WindowY := 48;
  471.    WindowWidth := 133;
  472.    WindowHeight := 133;
  473.  
  474.    LOOP
  475.       occuredEvents := EventMultiple ( MesageEvent + TimerEvent, 0, 0, 0,
  476.                                        0, 0, 0, 0, 0,
  477.                                        0, 0, 0, 0, 0,
  478.                                        ADR ( MessageBuffer ),
  479.                                        20, 0,
  480.                                        MouseX, MouseY, MouseButtonState,
  481.                                        ShiftKeyState, PressedKey,
  482.                                        MouseClicks );
  483.  
  484.       IF Message IN BITSET ( occuredEvents ) THEN Msg END;
  485.  
  486.       IF WindowHandle # NoWindow
  487.       THEN SampleMouseButton ( VDIhandle, MouseButtonState, MouseX, MouseY );
  488.            Redraw
  489.       END
  490.    END
  491. END Funny.
  492.